; ORIGINAL: 3dt2.1/examples/old-rb.scm
; $Id: old-rb.scm,v 1.3 1996/10/21 15:59:22 aed Exp $
;======================================================================
; Purpose---
;    Implement old rubberbanding interface on top of new one.
;
;======================================================================
  
(provide 'old-rb)

; This file can only be loaded once 
(if (bound? 'old-rb) (error 'old-rb "old-rb already loaded"))
  
;; Define the hooks.  rb-position-hook is still hard coded.
(define rb-start-hook #f)
(define rb-update-hook #f)
(define rb-stop-hook #f)
(define rb-repaint-hook #f)
(define rb-init-hook #f)
(define rb-end-hook #f)
  
;; Redefine the old primitives as compounds in terms of the new primitives.
(define rb:clear rbd:clear)
(define rb:push  rbd:push)
(define rb:pop   rbd:pop)
  
;; Args are a list of entity list and a start position passed as
;; ((ent1 ent2 ...) position)
;; Both arguments are optional, tho dragging no entities doesn't make
;; much sense.  That is how the old rb interface worked.
(define (rb:drag onoff . args)
  (if onoff
      (if (pair? args)
		  (rbd:drag #t (car args) (cadr args))
          (rbd:drag #t args))
      (rbd:remove-type rbd:drag?)))

(define (rb:generic onoff)
  (if onoff
      (rbd:generic #t)
      (rbd:remove-type rbd:generic?)))
  
(define (rb:line onoff . base-pos)
  (if onoff
      (if (pair? base-pos)
          (rbd:line #t (car base-pos))
          (rbd:line #t))
      (rbd:remove-type rbd:line?)))
  
(define (rb:rectangle onoff . base-pos)
  (if onoff
      (if (pair? base-pos)
          (rbd:rectangle #t (car base-pos))
          (rbd:rectangle #t))
      (rbd:remove-type rbd:rectangle?)))

; The old style rb:scheme used global hook functions.  The new style
; passes hook functions as a vector.  In order for the hooks to know
; which rbd:scheme they are being called on behalf of, an rbd:scheme is
; passed as the first argument.  Here we create a vector of lambda expressions
; that ignore the first argument and pass remaining args on to the old
; style global hooks.
(define (hook-vector)
  (vector
   (if (procedure? rb-init-hook) (lambda (self . args) (if (eqv? args '()) (rb-init-hook) (rb-init-hook args))) #f)
   (if (procedure? rb-start-hook) (lambda (self pe) (rb-start-hook pe)) #f)
   (if (procedure? rb-update-hook) (lambda (self pe) (rb-update-hook pe)) #f)
   (if (procedure? rb-stop-hook) (lambda (self) (rb-stop-hook)) #f)
   (if (procedure? rb-repaint-hook) (lambda (self view) (rb-repaint-hook view)) #f)
   (if (procedure? rb-position-hook) (lambda (self pe) (rb-position-hook pe)) #f)
   (if (procedure? rb-end-hook) (lambda (self) (rb-end-hook)) #f)))
  
(define (rb:scheme onoff . args)
  (if onoff
      (if (pair? args)
          (rbd:scheme #t (hook-vector) (car args))
          (rbd:scheme #t (hook-vector)))
      (rbd:remove-type rbd:scheme?)))
  
(define (rb:window onoff . base-evt)
  (if onoff
      (if (pair? base-evt)
          (rbd:window #t (car base-evt))
          (rbd:window #t))
      (rbd:remove-type rbd:window?)))

  
(define old-rb)
